home *** CD-ROM | disk | FTP | other *** search
/ Shareware Gold 2 / Shareware Gold II - Volume 2 Number 1 - Wayzata Technology (7071) (1991).iso / database / pds_base / utilprog.exe / lha / MAILABEL.SRC < prev    next >
Text File  |  1990-03-10  |  12KB  |  184 lines
  1. |2010 DIM LABLINFO%(5,20),LABLDESC$(20),YA$(|12),YA%(|12,2),ZS9(|13,1),YT$(|35),HEADER$(|35),TRAILER$(|35),PRTROW$(5,20),YT%(|35,8),YR$(|35)
  2. *23 |2015 DIM YH%(|02,|04),YE%(|02,|04) 'Keep track of first and last Detail record numbers
  3. 2020 ON ERROR GOTO 2060:OPEN "LABLSIZE.TYP" FOR INPUT AS #ZQ+1
  4. 2030 L$="":WHILE LEFT$(L$,1)<>"*":LINE INPUT #ZQ+1, L$:WEND 'look for the * after the instructions in LABLSIZE.TYP
  5. 2040 NUMLABL%=0:WHILE NOT EOF(ZQ+1):NUMLABL%=NUMLABL%+1:INPUT #ZQ+1, LABLINFO%(1,NUMLABL%),LABLINFO%(2,NUMLABL%),LABLINFO%(3,NUMLABL%),LABLINFO%(4,NUMLABL%),LABLINFO%(5,NUMLABL%),LABLDESC$(NUMLABL%):WEND
  6. 2050 CLOSE ZQ+1:GOTO 2100
  7. 2060 E=ERR:RESUME 2080
  8. 2080 CLS:IF E=53 THEN PRINT "The LABLSIZE.TYP file is missing from the DOS default drive." ELSE IF E=62 THEN PRINT "The * just ahead of the data lines has been removed from LABLSIZE.TYP file." ELSE PRINT "BASIC Error=";E;".  See your BASIC Manual"
  9. 2090 PRINT "Strike any key to end the program . . .":A$=INPUT$(1):GOTO 400
  10. 2100 CLS
  11. 2110 LOCATE 1,18,0:COLOR COLA%(2),COLA%(1)
  12. 2120 PRINT "PDS*BASE Data Base Label Printing Program";:COLOR 7,0
  13. |2130 ZPASS=1:ZF$="|15":ZA=|16
  14. 2140 ON ERROR GOTO 2190
  15. 2150 LOCATE 3,19:COLOR COLA%(2),0:PRINT "Reading sort keys from file ";ZF$;:COLOR 7,0::OPEN ZF$ FOR INPUT AS ZQ+1:IF ZPASS=1 THEN INPUT #ZQ+1, ZTDATE$,ZTTIME$:INPUT #ZQ+1, Z5
  16. |2160 IF ZPASS=1 THEN IF Z5<>ZS%(|16,6) THEN BEEP:LOCATE 4,2:COLOR 0,COLA%(4):PRINT "The number of records in the key file doesn't = Number of records in data base";:COLOR 7,0:CLOSE #ZQ+1:FOR X=1 TO 1000:NEXT:GOTO 2210
  17. 2170 IF ZPASS=1 THEN IF ZDATE$(ZA)<>ZTDATE$ OR ZTIME$(ZA)<>ZTTIME$ THEN BEEP:LOCATE 4,7:COLOR 0,COLA%(4):PRINT "Date & Time for the key file doesn't=Date & Time in the data base";:COLOR 7,0:CLOSE #ZQ+1:FOR X=1 TO 1000:NEXT:GOTO 2210
  18. 2180 ON ERROR GOTO 0:GOTO 2220
  19. 2190 RESUME 2200
  20. *39 2200 IF ZPASS=2 THEN 2210 ELSE ZF$=CHR$(ZT%(ZA,1,3)+64)+":"+LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":ZPASS=2:GOTO 2150
  21. *40 2200 IF ZPASS=2 THEN 2210 ELSE ZF$=LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":ZPASS=2:GOTO 2150
  22. *41 2205 RESUME 2210
  23. *42 2210 ON ERROR GOTO 0:CLOSE #ZQ+1:GOTO 2250
  24. *41 2210 LOCATE 5,8:PRINT "The sort key file can not be used - Run the sort program again.":LOCATE 6,20,1:PRINT "Strike any key to end the program . . .":a$=input$(1):GOTO 400
  25. *42 2220 ZZ5=0 'read the sort key file
  26. *42 2230 WHILE NOT EOF(ZQ+1):ZZ5=ZZ5+1:INPUT #ZQ+1, YA%(ZZ5,2):WEND 'read the live record numbers
  27. *42 2240 CLOSE #ZQ+1:IF ZZ5=ZS%(ZA,6) THEN IF ZPASS=1 THEN GOTO 2500 'the number of records in the sort key file may be larger if a master was deleted and re-created in the same dated session
  28. *42 |2250 LOCATE 5,11:COLOR COLA%(2),0:PRINT "The data base must be re-sorted from the '";ZS$(|16,1);"' file.";:COLOR 7,0:Z5=0:ZA=|16
  29. *42 2260 ZJJ=ZS%(ZA,2):IF ZPASS=2 AND ZZ5=ZS%(ZA,6) THEN ZJJ=ZZ5
  30. *42 2270 FOR ZJ=1 TO ZJJ
  31. *42 2280 IF ZZ5=ZS%(ZA,6) AND ZPASS=2 THEN ZR=YA%(ZJ,2) ELSE ZR=ZJ
  32. *42 2290 ZZ=1:GOSUB 610
  33. *42 |2300 IF ZL$<>STRING$(ZSIZE%(|16,|17),32) THEN Z5=Z5+1:YA$(Z5)=|22:YA%(Z5,1)=Z5:YA%(Z5,2)=ZR:LOCATE 6,25:PRINT ZR,ZL$;
  34. *42 2310 NEXT 'ZJ
  35. *42 |2320 ZREPTFLAG=0:IF Z5<> ZS%(|16,6) THEN ZS%(|16,6)=Z5:ZREPTFLAG=1 ' correct records assigned and set flags to correct the housekeeping record on closing the data base.
  36. *42 2330 SOUND 400,1:LOCATE 7,20:COLOR COLA%(2),0:PRINT "There will be a file sort delay.";:COLOR 7,0:T%=INT((80-LEN(YA$(1)))/2)
  37. *42 2340 ZZT$=TIME$:ZT1=(VAL(LEFT$(ZZT$,2))*3600)+(VAL(MID$(ZZT$,4,2))*60)+(VAL(RIGHT$(ZZT$,2)))
  38. *42 2350 ZI1=1:ZJ1=Z5:ZP=0
  39. *42 2360 ZI=ZI1:ZJ=ZJ1
  40. *42 2370 IF YA$(YA%(ZI,1))>YA$(YA%(ZJ,1)) THEN SWAP YA%(ZI,1),YA%(ZJ,1):SWAP YA%(ZI,2),YA%(ZJ,2):ZZS%=ABS(ZZS%-1)
  41. *42 2380 ZI=ZI+ZZS%:ZJ=ZJ-(1-ZZS%):IF ZI<ZJ THEN 2370
  42. *42 2390 IF ZI+1<ZJ1 THEN ZP=ZP+1:ZS9(ZP,0)=ZI+1:ZS9(ZP,1)=ZJ1
  43. *42 2400 ZJ1=ZI-1:IF ZI1<ZJ1 THEN 2360
  44. *42 2410 IF ZJ>0 THEN LOCATE 8,T%,0:PRINT YA$(YA%(ZJ,1)); 'remove this warm fuzzy line to speed up sort
  45. *42 2420 IF ZP THEN ZI1=ZS9(ZP,0):ZJ1=ZS9(ZP,1):ZP=ZP-1:GOTO 2360
  46. *42 2430 ZZT$=TIME$:ZT2=(VAL(LEFT$(ZZT$,2))*3600)+(VAL(MID$(ZZT$,4,2))*60)+(VAL(RIGHT$(ZZT$,2)))
  47. *42 2440 BEEP:LOCATE 8,1:PRINT SPC(79):LOCATE 8,20:COLOR COLA%(2),0:ZT3=ZT2-ZT1:IF ZT3 < 120 THEN PRINT "Elapsed time=";ZT3;" seconds" ELSE PRINT "Elapsed time =";INT(ZT3/60);" minutes ";INT( ( (ZT3/60)-INT(ZT3/60) ) * 60 );" seconds"
  48. *42 |2450 COLOR 7,0:ZPASS=1:ZF$="|15"
  49. *42 2460 OPEN ZF$ FOR OUTPUT AS ZQ+1:IF ZPASS=1 THEN WRITE #ZQ+1,ZDATE$(ZA);ZTIME$(ZA):PRINT #ZQ+1,Z5
  50. *42 2470 FOR ZI=1 TO Z5:PRINT #ZQ+1,YA%(ZI,2):NEXT 'ZI
  51. *42 2480 CLOSE #ZQ+1
  52. *39 2490 IF ZPASS=2 THEN 2500 ELSE ZF$=CHR$(ZT%(ZA,1,3)+64)+":"+LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":ZPASS=2:GOTO 2460
  53. *40 2490 IF ZPASS=2 THEN 2500 ELSE ZF$=LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":ZPASS=2:GOTO 2460
  54. 2500 '****** Select The Label Stock ******
  55. 2510 PRTDESC$=STRING$(30,32)
  56. 2520 LOCATE 10,10
  57. 2530 COLOR COLA%(2),0
  58. 2540 PRINT"Enter Label Type Number";
  59. |2550 STOCKNUMBER%=|33
  60. 2560 FLD$="  "
  61. 2570 TYPELOOP%=1
  62. 2580 WHILE TYPELOOP%=1
  63. 2590    LOCATE 24,7,0
  64. 2600    COLOR 15,0
  65. 2610    PRINT "Enter the Label Stock Number or press Space Bar to toggle choices";
  66. 2620    COLOR 7,0
  67. 2630    LSET FLD$=MID$(STR$(STOCKNUMBER%),2)
  68. 2640    LSET PRTDESC$=LABLDESC$(STOCKNUMBER%)
  69. 2650    COLOR 0,COLA%(3)
  70. 2660    LOCATE 10,34
  71. 2670    PRINT FLD$;
  72. 2680    LOCATE 10,37
  73. 2690    COLOR COLA%(2),COLB%(1)
  74. 2700    PRINT PRTDESC$;
  75. 2710    LOCATE 10,34,1
  76. 2720    COLOR 0,COLA%(3)
  77. 2730    C$=""
  78. 2740    C1LOOP%=1
  79. 2750    WHILE C1LOOP%=1
  80. 2760       C1$=""
  81. 2770       WHILE C1$=""
  82. 2780          C1$=INKEY$
  83. 2790       WEND
  84. 2800       IF ASC(C1$)=32 THEN STOCKNUMBER%=STOCKNUMBER%+1:C1LOOP%=2:IF STOCKNUMBER% > NUMLABL% THEN STOCKNUMBER%=1
  85. 2810       IF ASC(C1$) = 13 THEN TYPELOOP%=0:C1LOOP%=0
  86. 2820       IF (ASC(C1$) < 48 OR ASC(C1$) > 57) AND C1LOOP%=1 THEN BEEP ELSE IF C1LOOP%=1 THEN PRINT C1$;:C1LOOP%=0:C$=C1$
  87. 2830    WEND
  88. 2840    C2LOOP%=1
  89. 2850    WHILE C1LOOP%=0 AND C2LOOP%=1 AND TYPELOOP%=1
  90. 2860       C2$=""
  91. 2870       WHILE C2$=""
  92. 2880          C2$=INKEY$
  93. 2890       WEND
  94. 2900       IF ASC(C2$)=32 THEN STOCKNUMBER%=STOCKNUMBER%+1:IF STOCKNUMBER% > NUMLABL% THEN STOCKNUMBER%=1
  95. 2910       IF ASC(C2$) = 13 THEN TYPELOOP%=0:C2LOOP%=0
  96. 2920       IF (ASC(C2$) < 48 OR ASC(C2$) > 57) AND C2LOOP%=1 THEN BEEP ELSE PRINT C2$;:C$=C$+C2$:C2LOOP%=0
  97. 2930    WEND
  98. 2940    COLOR 7,0:IF VAL(C$) > 0 THEN STOCKNUMBER%=VAL(C$)
  99. 2950    IF STOCKNUMBER%>NUMLABL% OR STOCKNUMBER%<1 THEN LOCATE 23,1,0:PRINT SPC(79):BEEP:LOCATE 24,18,0:PRINT "Label Stock Number must be between 1 and"+STR$(NUMLABL%);:TYPELOOP%=1
  100. 2955    IF STOCKNUMBER%>NUMLABL% OR STOCKNUMBER%<1 THEN LOCATE 24,26:PRINT "Strike any key to continue";:A$=INPUT$(1):LOCATE 23,1:PRINT SPC(79):LOCATE 24,1:PRINT SPC(79):STOCKNUMBER%=1
  101. 2960 WEND
  102. 2970 LSET PRTDESC$=LABLDESC$(STOCKNUMBER%)
  103. 2980 LOCATE 10,37
  104. 2990 COLOR COLA%(2),COLB%(1)
  105. 3000 PRINT PRTDESC$;:COLOR 7,0
  106. 3010 LOCATE 24,1,0
  107. 3020 PRINT SPC(79)
  108. 3030 NUMROWS%=LABLINFO%(3,STOCKNUMBER%):ACROSS%=LABLINFO%(4,STOCKNUMBER%):ACROSSTAB%=LABLINFO%(5,STOCKNUMBER%):ACROSSPOS%=0
  109. 3100 LOCATE 12,12,0:PRINT "Turn on the printer - Strike (gently) any key when ready";:A$=INPUT$(1)
  110. |3110 FOR ZI=1 TO |35:FOR ZJ=1 TO 8:READ YT%(ZI,ZJ):NEXT:READ HEADER$(ZI),TRAILER$(ZI):NEXT ZI
  111. 3120 ' YT%(X,Y) X=Field on report, Y=1 is file number, 2=field in that file, 3=lead to file, 4=lead to field
  112. 3130 ' 5=Detail fld action code (1=1st Detail, 2=last, 3=all), 6=Associated Master if this is a Detail
  113. 3140 ' 7=Which Detail set for this Detail's Master, 8=1 If field starts new row
  114. *44
  115. 3300 YL$="":ZA=0:FIRSTLABEL%=1
  116. 3310 WIDTH "LPT1:",254 'Set up more than 80 columns
  117. |3320 LPRINT |26 'Turn on Near Letter Quality printing - remove this line for faster draft quality
  118. |3330 FOR ZJ=1 TO NUMROWS%:FOR ZK=1 TO ACROSS%:PRTROW$(ZK,ZJ)=STRING$(LABLINFO%(2,STOCKNUMBER%)-2,32):NEXT:NEXT:FOR ZJ=1 TO |35:YT$(ZJ)=STRING$(LABLINFO%(2,STOCKNUMBER%)-2,32):NEXT:ACROSSPOS%=0
  119. 3340 FOR ZI=1 TO Z5 'loop for each record in the sort file
  120. 3350 YF=0:MOREDETAIL%=0:YJ=1:LABLSKIP%=0
  121. |3360 FOR ZJ=YJ TO |35 'loop for each field in the Label
  122. 3370 IF ZJ=1 THEN ZZ=1:ZA=YT%(1,1):ZR=YA%(ZI,2):GOSUB 610:LSET YT$(1)=Y$(YT%(1,2),ZA):GOTO 3420 'read the record for the first field
  123. *47 3380 IF ZS%(YT%(ZJ,1),1)=2 GOTO 3440
  124. 3390 IF ZA=YT%(ZJ,1) THEN LSET YT$(ZJ)=Y$(YT%(ZJ,2),ZA):GOTO 3580 'additional field in the same master
  125. 3400 IF ZA<>YT%(ZJ,1) AND ZS%(YT%(ZJ,1),1)=1 AND YR$(ZJ)=STRING$(YT%(ZJ,4),32) THEN GOTO 3580 'skip the new field if the field leading to it was blank
  126. 3410 IF ZA<>YT%(ZJ,1) AND ZS%(YT%(ZJ,1),1)=1 THEN ZA=YT%(ZJ,1):ZR$=YR$(ZJ):GOSUB 500:GOSUB 600:LSET YT$(ZJ)=Y$(YT%(ZJ,2),ZA) 'field in a different master
  127. *47 3420 IF ZS%(ZA,4)>0 THEN FOR ZK=1 TO ZS%(ZA,4):YH%(ZA,ZK)=ZH(ZK):YE%(ZA,ZK)=ZE(ZK):NEXT 'ZK  store the chain head and ends for this master record
  128. *48 3420 REM continuation line - do not remove
  129. *58
  130. *47 3430 GOTO 3540
  131. *47 3440 'handle the detail record DO NOT remove this REM line
  132. *47 3450 IF YT%(ZJ,1) = YT%(ZJ-1,1) THEN GOTO 3540
  133. *47 3460 ZR=0:ZA=YT%(ZJ,1)
  134. *47 3470 IF YF>0 THEN ZR=YF:GOTO 3500
  135. *47 3480 IF YT%(ZJ,5)<>2 THEN ZR=YH%(YT%(ZJ,6),YT%(ZJ,7))
  136. *47 3490 IF YT%(ZJ,5)=2 THEN ZR=YE%(YT%(ZJ,6),YT%(ZJ,7))
  137. *47 3500 IF ZR>0 THEN ZZ=1:GOSUB 610 'read the 1st, last or next detail record
  138. *47 3510 IF ZR=0 GOTO 3580
  139. *47 3520 IF YT%(ZJ,5)=3 AND ZF>0 THEN MOREDETAIL%=1
  140. *47 3530 IF MOREDETAIL%=1 THEN IF ZF>0 THEN YJ=ZJ:YF=ZF ELSE YF=0 'set up to read additional details
  141. *47 3540 IF YT%(ZJ,5)<>999 THEN LSET YT$(ZJ)=Y$(YT%(ZJ,2),ZA)
  142. |3550 FOR Z1=1 TO |35:IF ZA=YT%(Z1,3) THEN YR$(Z1)=Y$(YT%(Z1,4),ZA) 'set up future field search value
  143. 3560 NEXT 'Z1
  144. 3580 NEXT 'ZJ
  145. 3590 IF LABLSKIP%=0 THEN GOSUB 4000 'print Label
  146. 3600 IF YF>0 THEN GOTO 3360 'repeat for additional Details
  147. 3610 NEXT 'ZI
  148. 3620 IF ACROSSPOS%>0 THEN GOSUB 4200
  149. |3630 LPRINT |27 'Turn off Near Letter Quality printing - remove this line if if you removed LINE 2595
  150. 3640 'all done"
  151. 3650 GOTO 400
  152. 4000 '***** Load Label Buffer Subroutine *****
  153. 4010 ROW%=1:ROWCOLUMN%=1:SKIP%=0:ACROSSPOS%=ACROSSPOS%+1
  154. |4020 FOR J=1 TO |35
  155. 4030 IF YT%(J,8)=1 THEN ROWCOLUMN%=1:IF SKIP%=0 THEN ROW%=ROW%+1
  156. 4040 SKIP%=0:FLDLEN%=LEN(YT$(J)):IF YT$(J)=STRING$(FLDLEN%,32) THEN SKIP%=1:GOTO 4100 ELSE IF RIGHT$(YT$(J),1)<>" " THEN GOTO 4070 ' field is full
  157. 4050 FOR K=FLDLEN% TO 1 STEP -1:IF MID$(YT$(J),K,1)<>" " THEN FLDLEN%=K:K=1
  158. 4060 NEXT 'K
  159. 4070 MID$(PRTROW$(ACROSSPOS%,ROW%),ROWCOLUMN%,LEN(HEADER$(J)))=HEADER$(J):ROWCOLUMN%=ROWCOLUMN%+LEN(HEADER$(J)) 'moves the header into PRTROW$
  160. 4080 MID$(PRTROW$(ACROSSPOS%,ROW%),ROWCOLUMN%,FLDLEN%)=LEFT$(YT$(J),FLDLEN%):ROWCOLUMN%=ROWCOLUMN%+FLDLEN% 'moves the field into PRTROW$
  161. 4090 MID$(PRTROW$(ACROSSPOS%,ROW%),ROWCOLUMN%,LEN(TRAILER$(J)))=TRAILER$(J):ROWCOLUMN%=ROWCOLUMN%+LEN(TRAILER$(J)) 'moves trailer into PRTROW$
  162. 4100 NEXT 'J
  163. 4110 IF ACROSSPOS%=ACROSS% THEN GOSUB 4200
  164. 4120 RETURN
  165. 4200 'Subroutine to print the labels
  166. 4210 FOR J=1 TO ROW%
  167. 4220 PRTAB%=1
  168. 4230 FOR K=1 TO ACROSS%
  169. 4240 IF K>1 THEN PRTAB%=((K-1)*ACROSSTAB%)
  170. 4250 LPRINT TAB(PRTAB%);PRTROW$(K,J);
  171. 4260 NEXT:LPRINT:NEXT
  172. 4270 FOR J=ROW%+1 TO NUMROWS%
  173. 4280 LPRINT
  174. 4290 NEXT 'J
  175. 4300 WHILE FIRSTLABEL%=1
  176. 4310    SOUND 400,1:LOCATE 14,26,0:COLOR 15,0:PRINT "Is the label lined up Ok? ";:COLOR 0,COLA%(3):PRINT "Y";:LOCATE ,POS(0)-1,1:A$="":WHILE A$="":A$=INKEY$:WEND:IF ASC(A$)=13 THEN A$="Y"
  177. 4320    PRINT A$;:COLOR 7,0
  178. 4330    IF A$="N" OR A$="n" THEN FOR J=1 TO 200:NEXT:LOCATE 14,1:PRINT SPC(79):LOCATE 12,1:PRINT SPC(79):SOUND 400,1:LOCATE 12,12,0:PRINT "Turn on the printer - Strike (gently) any key when ready";:A$=INPUT$(1):GOTO 4210
  179. 4340    FIRSTLABEL%=0
  180. 4350 WEND
  181. 4360 ACROSSPOS%=0:FOR J=1 TO NUMROWS%:FOR K=1 TO ACROSS%:LSET PRTROW$(K,J)=" ":NEXT:NEXT:RETURN 'LSET is used to reuse memory locations and prevent garbage collection
  182. 4370 RETURN
  183. *31 Copyright 1987 by PRO DEV Software
  184.